home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 24 / CU Amiga Magazine's Super CD-ROM 24 (1998)(EMAP Images)(GB)(Track 1 of 2)[!][issue 1998-07].iso / CUCD / Programming / SWI / source / boot / toplevel.pl < prev    next >
Encoding:
Text File  |  1997-11-04  |  13.2 KB  |  563 lines
  1. /*  $Id: toplevel.pl,v 1.34 1997/11/04 10:38:22 jan Exp $
  2.  
  3.     Copyright (c) 1990 Jan Wielemaker. All rights reserved.
  4.     jan@swi.psy.uva.nl
  5.  
  6.     Purpose: top level user interaction
  7. */
  8.  
  9. :- module($toplevel,
  10.     [ $initialise/0            % start Prolog (does not return)
  11.     , $toplevel/0            % Prolog top-level (re-entrant)
  12.     , $abort/0             % restart after an abort
  13.     , $break/0             % live in a break
  14.     , $compile/0             % `-c' toplevel
  15.     , $welcome/0            % banner
  16.     , prolog/0             % user toplevel predicate
  17.     , time/1            % time query
  18.     , $set_prompt/1            % set the main prompt
  19.     , at_initialization/1        % goals to run at initialization
  20.     , (initialization)/1        % initialization goal (directive)
  21.     ]).
  22.  
  23.  
  24.         /********************************
  25.         *         INITIALISATION        *
  26.         *********************************/
  27.  
  28. :- dynamic
  29.     loaded_init_file/1.        % already loaded init files
  30.  
  31. $welcome :-
  32.     feature(version, Version),
  33.     Major is Version // 10000,
  34.     Minor is (Version // 100) mod 100,
  35.     Patch is Version mod 100,
  36.     $ttyformat('Welcome to SWI-Prolog (Version ~w.~w.~w)~n',
  37.            [Major, Minor, Patch]),
  38.     $ttyformat('Copyright (c) 1993-1997 University of Amsterdam.  '),
  39.     $ttyformat('All rights reserved.~n~n'),
  40.     $ttyformat('For help, use ?- help(Topic). or ?- apropos(Word).~n~n').
  41.  
  42. $load_init_file(none) :- !.
  43. $load_init_file(Base) :-
  44.     loaded_init_file(Base), !.
  45. $load_init_file(Base) :-
  46.     member(Prefix, ['', '~/']),
  47.     concat(Prefix, Base, InitFile), 
  48.     access_file(InitFile, read), !, 
  49.     asserta(loaded_init_file(Base)),
  50.     user:ensure_loaded(InitFile).
  51. $load_init_file(_).
  52.  
  53. $load_system_init_file :-
  54.     loaded_init_file(system), !.
  55. $load_system_init_file :-
  56.     $option(system_init_file, Base, Base),
  57.     (   Base == none
  58.     ->  asserta(loaded_init_file(system))
  59.     ;   feature(home, Home),
  60.         file_name_extension(Base, rc, Name),
  61.         concat_atom([Home, '/', Name], File),
  62.         access_file(File, read),
  63.         asserta(loaded_init_file(system)),
  64.         load_files(user:File, [silent(true)]), !
  65.     ).
  66. $load_system_init_file.
  67.  
  68. $load_gnu_emacs_interface :-
  69.     getenv('EMACS', t),
  70.     $argv(Args),
  71.     memberchk('+C', Args), !,
  72.     user:ensure_loaded(library(emacs_interface)).
  73. $load_gnu_emacs_interface.
  74.  
  75.          /*******************************
  76.          *     AT_INITIALISATION    *
  77.          *******************************/
  78.  
  79. :- module_transparent
  80.     at_initialization/1,
  81.     (initialization)/1.
  82. :- dynamic
  83.     $at_initialization/1.
  84.  
  85. at_initialization(Spec) :-
  86.     $strip_module(Spec, Module, Goal),
  87.     '$toplevel':assert($at_initialization(Module:Goal)).
  88.  
  89. $run_at_initialization :-
  90.     \+ feature(saved_program, true), !.
  91. $run_at_initialization :-
  92.     $argv(Argv),
  93.     memberchk('-d', Argv), !,
  94.     (   $at_initialization(Goal),
  95.         (   $feedback('initialization(~p) ... ', [Goal]),
  96.         Goal
  97.         ->  $feedback('ok~n', []),
  98.         fail
  99.         ;   $feedback('FAILED~n', []),
  100.         $warning('at_initialization goal ~p failed~n', [Goal]),
  101.         fail
  102.         )
  103.     ;   true
  104.     ).
  105. $run_at_initialization :-
  106.     (   $at_initialization(Goal),
  107.         (   Goal
  108.         ->  fail
  109.         ;   $warning('at_initialization goal ~p failed~n', [Goal]),
  110.         fail
  111.         )
  112.     ;   true
  113.     ).
  114.  
  115. $feedback(Fmt, Args) :-
  116.     format(Fmt, Args),
  117.     flush_output(user_output).
  118.  
  119. %    initialization(+Goal)
  120. %
  121. %    Runs `Goal' both a load and initialization time.
  122.  
  123. initialization(Goal) :-
  124.     at_initialization(Goal),
  125.     Goal.
  126.  
  127.  
  128.          /*******************************
  129.          *     FILE SEARCH PATH (-p)    *
  130.          *******************************/
  131.  
  132. $set_file_search_paths :-
  133.     $argv(Argv),
  134.     append(H, ['-p', Path|_], Argv),
  135.     \+ member(H, '--'),
  136.     (   atom_chars(Path, Chars),
  137.         (    phrase($search_path(Name, Aliases), Chars)
  138.         ->    reverse(Aliases, Aliases1),
  139.             forall(member(Alias, Aliases1),
  140.                asserta(user:file_search_path(Name, Alias)))
  141.         ;    $warning('-p: failed to parse ~w', [Path]),
  142.             nodebug
  143.         )
  144.     ->  true
  145.     ),
  146.     fail ; true.
  147.  
  148. $search_path(Name, Aliases) -->
  149.     $string(NameChars),
  150.     "=", !,
  151.     {atom_chars(Name, NameChars)},
  152.     $search_aliases(Aliases).
  153.  
  154. $search_aliases([Alias|More]) -->
  155.     $string(AliasChars),
  156.     ":", !,
  157.     { $make_alias(AliasChars, Alias) },
  158.     $search_aliases(More).
  159. $search_aliases([Alias]) -->
  160.     $string(AliasChars),
  161.     $eos, !,
  162.     { $make_alias(AliasChars, Alias) }.
  163.  
  164. $string(X) --> {X=[_|_]}, X.
  165.  
  166. $eos([], []).
  167.  
  168. $make_alias(Chars, Alias) :-
  169.     term_to_atom(Alias, Chars),
  170.     (   atom(Alias)
  171.     ;   functor(Alias, F, 1),
  172.         F \== /
  173.     ), !.
  174. $make_alias(Chars, Alias) :-
  175.     atom_chars(Alias, Chars).
  176.  
  177.  
  178.          /*******************************
  179.          *   LOADING ASSIOCIATED FILES    *
  180.          *******************************/
  181.  
  182. $load_associated_file :-
  183.     feature(associate, Ext),
  184.     $argv([_,OsFile]),
  185.     prolog_to_os_filename(File, OsFile),
  186.     file_name_extension(_, Ext, File),
  187.     access_file(File, read),
  188.     file_directory_name(File, Dir),
  189.     chdir(Dir),
  190.     consult(user:File), !,
  191.     concat('SWI-Prolog -- ', File, Title),
  192.     G = user:window_title(_, Title),
  193.     (   current_predicate(_, G)
  194.     ->  G
  195.     ;   true
  196.     ),
  197.     nl.
  198. $load_associated_file.
  199.  
  200.  
  201.         /********************************
  202.         *        TOPLEVEL GOALS         *
  203.         *********************************/
  204.  
  205. :- flag($banner_goal, _, $welcome).
  206. :- flag($qid, _, 1).
  207.  
  208. $initialise :-
  209.     $clean_history,
  210.     $set_file_search_paths,
  211.     $run_at_initialization,
  212.     $load_system_init_file,
  213.     $load_gnu_emacs_interface,
  214.     $option(init_file, File, File), 
  215.     $load_init_file(File), 
  216.     $option(goal, GoalAtom, GoalAtom), 
  217.     term_to_atom(Goal, GoalAtom), 
  218.     (   Goal == $welcome
  219.     ->  flag($banner_goal, TheGoal, TheGoal)
  220.     ;   TheGoal = Goal
  221.     ),
  222.     ignore(user:TheGoal),
  223.     $load_associated_file.
  224.  
  225. $abort :-
  226.     see(user), 
  227.     tell(user), 
  228.     flag($break_level, _, 0), 
  229.     flag($compilation_level, _, 0),
  230.     $calleventhook(abort),
  231.     $ttyformat('~nExecution Aborted~n~n'),
  232.     $toplevel.
  233.  
  234. $break :-
  235.     flag($break_level, Old, Old), 
  236.     succ(Old, New), 
  237.     flag($break_level, _, New), 
  238.     $ttyformat('Break Level [~d]~n', [New]),
  239.     $runtoplevel,
  240.     $calleventhook(exit_break(New)),
  241.     $ttyformat('[exit break level ~d]~n', [New]),
  242.     flag($break_level, _, Old), !.
  243.  
  244. :- $hide($toplevel, 0).            % avoid in the GUI stacktrace
  245.  
  246. $toplevel :-
  247.     $runtoplevel,
  248.     $ttyformat('[halt]~n', []).        
  249.  
  250. $runtoplevel :-
  251.     $option(top_level, TopLevelAtom, TopLevelAtom), 
  252.     term_to_atom(TopLevel, TopLevelAtom), 
  253.     user:TopLevel.
  254.  
  255. %    $compile
  256. %    Toplevel called when invoked with -c option.
  257.  
  258. $compile :-
  259.     $compile_wic.
  260.  
  261.  
  262.         /********************************
  263.         *    USER INTERACTIVE LOOP      *
  264.         *********************************/
  265.  
  266. prolog :-
  267.     flag($tracing, _, off), 
  268.     flag($break_level, BreakLev, BreakLev), 
  269.     repeat, 
  270.         (   $module(TypeIn, TypeIn), 
  271.         $system_prompt(TypeIn, BreakLev, Prompt),
  272.         prompt(Old, '|    '), 
  273.         trim_stacks,
  274.         read_query(Prompt, Goal, Bindings),
  275.         prompt(_, Old),
  276.         call_expand_query(Goal, ExpandedGoal,
  277.                   Bindings, ExpandedBindings)
  278.         ->  $execute(ExpandedGoal, ExpandedBindings)
  279.         ), !.
  280.  
  281.  
  282. read_query(Prompt, Goal, Bindings) :-
  283.     feature(history, N),
  284.     N =< 0, !,
  285.     remove_history_prompt(Prompt, Prompt1),
  286.     repeat,                % over syntax errors
  287.     prompt1(Prompt1),
  288.     (   feature(readline, true)
  289.     ->  $raw_read(user_input, Line),
  290.         atom_chars(Line, LineChars),
  291.         append(LineChars, ".", CompleteLine),
  292.         call(rl_add_history(CompleteLine)),
  293.         $term_to_atom(Goal, Line, Bindings, 1)
  294.     ;   read_term(user_input, Goal, [variable_names(Bindings)])
  295.     ), !.
  296. read_query(Prompt, Goal, Bindings) :-
  297.     seeing(Old), see(user_input),
  298.     (   read_history(h, '!h', 
  299.              [trace, end_of_file], 
  300.              Prompt, Goal, Bindings)
  301.     ->  see(Old)
  302.     ;   see(Old),
  303.         fail
  304.     ).
  305.  
  306. remove_history_prompt(Prompt0, Prompt) :-
  307.     atom_chars(Prompt0, Chars0),
  308.     clean_history_prompt_chars(Chars0, Chars1),
  309.     delete_leading_blanks(Chars1, Chars),
  310.     atom_chars(Prompt, Chars).
  311.  
  312. clean_history_prompt_chars([], []).
  313. clean_history_prompt_chars([0'%, 0'!|T], T) :- !.
  314. clean_history_prompt_chars([H|T0], [H|T]) :-
  315.     clean_history_prompt_chars(T0, T).
  316.  
  317. delete_leading_blanks([32|T0], T) :- !,
  318.     delete_leading_blanks(T0, T).
  319. delete_leading_blanks(L, L).
  320.  
  321.  
  322. set_default_history :-
  323.     (   feature(readline, true)
  324.     ->  set_feature(history, 0)
  325.     ;   set_feature(history, 15)
  326.     ).
  327.  
  328. :- initialization set_default_history.
  329.  
  330.  
  331.         /********************************
  332.         *            PROMPTING        *
  333.         ********************************/
  334.  
  335. :- dynamic
  336.     $prompt/1.
  337.  
  338. $prompt("%m%l%! ?- ").
  339.  
  340. $set_prompt(P) :-
  341.     atom_chars(P, S),
  342.     retractall($prompt(_)),
  343.     assert($prompt(S)).
  344.  
  345.  
  346. $system_prompt(Module, BrekLev, Prompt) :-
  347.     $prompt(P0),
  348.     (    Module \== user
  349.     ->   $substitute("%m", [Module, ": "], P0, P1)
  350.     ;    $substitute("%m", [], P0, P1)
  351.     ),
  352.     (    BrekLev \== 0
  353.     ->   $substitute("%l", ["[", BrekLev, "] "], P1, P2)
  354.     ;    $substitute("%l", [], P1, P2)
  355.     ),
  356.     atom_chars(Prompt, P2).
  357.     
  358. $substitute(From, T, Old, New) :-
  359.     convert_to(T, T0),
  360.     flatten(T0, To),
  361.     append(Pre, S0, Old),
  362.     append(From, Post, S0) ->
  363.     append(Pre, To, S1),
  364.     append(S1, Post, New), !.
  365. $substitute(_, _, Old, Old).
  366.     
  367. convert_to([], []).
  368. convert_to([A|T], [S|R]) :-
  369.     atomic(A), !,
  370.     name(A, S),
  371.     convert_to(T, R).
  372. convert_to([S|T], [S|R]) :-
  373.     convert_to(T, R).
  374.  
  375.         /********************************
  376.         *           EXECUTION        *
  377.         ********************************/
  378.  
  379. $execute(Var, _) :-
  380.     var(Var), !,
  381.     $ttyformat('... 1,000,000 ............ 10,000,000 years later~n~n'),
  382.     $ttyformat('~t~8|>> 42 << (last release gives the question)~n'),
  383.     fail.
  384. $execute(end_of_file, _) :-
  385.      $ttyformat('~N'), !.
  386. $execute(Goal, Bindings) :-
  387.     $module(TypeIn, TypeIn), 
  388.     TypeIn:$dwim_correct_goal(Goal, Bindings, Corrected), !, 
  389.     $execute_goal(Corrected, Bindings).
  390. $execute(_, _) :-
  391.     notrace, 
  392.     $ttyformat('~nNo~n'),
  393.     fail.
  394.  
  395. $execute_goal(trace, []) :-
  396.     trace, 
  397.     $ttyformat('~n'),
  398.     $write_bindings([]), !, 
  399.     fail.
  400. $execute_goal(Goal, Bindings) :-
  401.     $module(TypeIn, TypeIn), 
  402.     flag($qid, Qid, Qid+1),
  403.     TypeIn:asserta(($user_query(Qid, Bindings) :- Goal), Ref),
  404.     $set_user_goal_attributes(TypeIn),
  405.     (   TypeIn:$user_query(Qid, Bindings),
  406.         flush,
  407.         call_expand_answer(Bindings, NewBindings),
  408.         $ttyformat('~n'),
  409.         (    $write_bindings(NewBindings)
  410.         ->    !,
  411.             notrace,
  412.         $calleventhook(finished_query(Qid, true)),
  413.         erase(Ref),
  414.         fail
  415.         )
  416.     ;   notrace, 
  417.         $ttyformat('~nNo~n'),
  418.         $calleventhook(finished_query(Qid, false)),
  419.         erase(Ref),
  420.         fail
  421.     ).
  422.  
  423. $set_user_goal_attributes(TypeIn) :-
  424.     TypeIn:(($hide($user_query, 2),
  425.          $show_childs($user_query, 2))).
  426.  
  427. $write_bindings([]) :- !, 
  428.     $ttyformat('Yes~n').
  429. $write_bindings(Bindings) :-
  430.     repeat,
  431.         $output_bindings(Bindings),
  432.         get_respons(Action),
  433.     (   Action == redo
  434.     ->  !, fail
  435.     ;   Action == show_again
  436.     ->  fail
  437.     ;   !, format(user_output, '~n~nYes~n', [])
  438.     ).
  439.  
  440. :- flag($toplevel_print_predicate, _, print).
  441.  
  442. $output_bindings([]) :- !,
  443.     $ttyformat('Yes~n').
  444. $output_bindings([Name = Var]) :- !,
  445.     $output_binding(Name, Var),
  446.     write(user_output, ' '),
  447.     ttyflush.
  448. $output_bindings([Name = Var|Rest]) :-
  449.     $output_binding(Name, Var),
  450.     nl(user_output),
  451.     $output_bindings(Rest).
  452.  
  453. $output_binding(Name, Var) :-
  454.     write(user_output, Name),
  455.     write(user_output, ' = '),
  456.     flag($toplevel_print_predicate, Pred, Pred),
  457.     Goal =.. [Pred, user_output, Var],
  458.     Goal.
  459.  
  460. get_respons(Action) :-
  461.     repeat,
  462.         ttyflush,
  463.         get_single_char(Char),
  464.         answer_respons(Char, Action),
  465.         (   Action == again
  466.         ->  $ttyformat('Action? '),
  467.         fail
  468.         ;   !
  469.         ).
  470.  
  471. answer_respons(Char, again) :-
  472.     memberchk(Char, "?h"), !,
  473.     show_toplevel_usage.
  474. answer_respons(Char, redo) :-
  475.     memberchk(Char, ";nrNR"), !,
  476.     $format_if_tty(';~n').
  477. answer_respons(Char, redo) :-
  478.     memberchk(Char, "tT"), !,
  479.     trace,
  480.     $format_if_tty('; [trace]~n').
  481. answer_respons(Char, continue) :-
  482.     memberchk(Char, [0'c, 0' , 10, 13, 0'y, 0'Y]), !.
  483. answer_respons(0'b, show_again) :- !,
  484.     break.
  485. answer_respons(Char, show_again) :-
  486.     print_predicate(Char, Pred), !,
  487.     $format_if_tty('~w~n', [Pred]),
  488.     flag($toplevel_print_predicate, _, Pred).
  489. answer_respons(_, again) :-
  490.     $ttyformat('~nUnknown action (h for help)~nAction? '),
  491.     ttyflush.
  492.  
  493. print_predicate(0'd, display).
  494. print_predicate(0'w, write).
  495. print_predicate(0'p, print).
  496.  
  497. show_toplevel_usage :-
  498.     $ttyformat('~nActions:~n'),
  499.     $ttyformat('; (n, r):     redo    t:               trace & redo~n'),
  500.     $ttyformat('b:            break   c (ret, space):  continue~n'),
  501.     $ttyformat('d:            display p                print~n'),
  502.     $ttyformat('w:            write   h (?):           help~n').
  503.  
  504. $format_if_tty(Fmt) :-
  505.     $format_if_tty(Fmt, []).
  506. $format_if_tty(Fmt, Args) :-
  507.     $tty, !,
  508.     $ttyformat(Fmt, Args).
  509. $format_if_tty(_, _).
  510.  
  511. :- module_transparent
  512.     time/1, 
  513.     $time_call/2.
  514.  
  515. time(Goal) :-
  516.     statistics(cputime, OldTime), 
  517.     statistics(inferences, OldInferences), 
  518.     $time_call(Goal, Result), 
  519.     statistics(inferences, NewInferences), 
  520.     statistics(cputime, NewTime), 
  521.     UsedTime is NewTime - OldTime, 
  522.     UsedInf  is NewInferences - OldInferences, 
  523.     (   UsedTime =:= 0
  524.     ->  Lips = 'Infinite'
  525.     ;   Lips is integer(UsedInf / UsedTime)
  526.     ), 
  527.     $ttyformat('~D inferences in ~2f seconds (~w Lips)~n',
  528.             [UsedInf, UsedTime, Lips]),
  529.     Result == yes.
  530.  
  531. $time_call(Goal, yes) :-
  532.     Goal, !.
  533. $time_call(_Goal, no).
  534.  
  535. unhandled_exception(false, Term) :- !,
  536.         $warning('Unhandled exception'),
  537.     print_message(error, Term),
  538.     $ttyformat('~nNo~n').
  539. unhandled_exception(true, _Term) :-
  540.     $warning('Unhandled exception'),
  541.     $ttyformat('~nNo~n').
  542.  
  543.  
  544.          /*******************************
  545.          *        EXPANSION        *
  546.          *******************************/
  547.  
  548. :- user:dynamic(expand_query/4).
  549. :- user:multifile(expand_query/4).
  550.  
  551. call_expand_query(Goal, Expanded, Bindings, ExpandedBindings) :-
  552.     user:expand_query(Goal, Expanded, Bindings, ExpandedBindings), !.
  553. call_expand_query(Goal, Goal, Bindings, Bindings).
  554.  
  555.  
  556. :- user:dynamic(expand_answer/2).
  557. :- user:multifile(expand_answer/2).
  558.  
  559. call_expand_answer(Goal, Expanded) :-
  560.     user:expand_answer(Goal, Expanded), !.
  561. call_expand_answer(Goal, Goal).
  562.  
  563.